(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

open XNum
open UniTools
open Logging
open Dim
open FontMetric
open Box
  
let tracing_line_breaks = ref false
let num_100 = num_of_int 100
let num_13 = num_of_int 13
let num_m13 = num_of_int (-13)
let num_m1 = num_of_int (-1)
let num_1_2 = num_of_ints 1 2
  
type line_break_params = {
  pre_tolerance : num;
  tolerance : num;
  looseness : int;
  line_penalty : num;
  adj_demerits : num;
  double_hyphen_demerits : num;
  final_hyphen_demerits : num;
  emergency_stretch : num;
  river_demerits : num;
  river_threshold : num;
  simple_breaking : bool
} (* with sexp_of *)

type par_params = {
  measure : num;
  par_indent : dim;
  par_fill_skip : dim;
  par_skip : dim;
  left_skip : dim;
  right_skip : dim;
  par_shape : int -> (num * num);
  pre_break : (*int ->*) extended_glyph_item list;
  post_break : (*int ->*) extended_glyph_item list;
  post_process_line : box list -> box list
} (* with sexp_of *)

(*
  |calc_adjust_ratio <line-width> <goal-width> <background-width>| calculates the adjustment
  ratio of the line.
*)
let calc_adjust_ratio line_width goal_width background_width =
  let width = xdim_add line_width background_width in
  let delta = sub_num goal_width width.xd_base in
  let s =
    if lt_num delta num_zero
    then xdim_max_shrink width
    else xdim_max_stretch width
  in
    if ge_num s infinite then
      num_zero
    else if gt_num s num_zero then
      div_num delta s
    else if ge_num delta num_zero then
      infinite else minus_infinite
  
(*
  |calc_demerits <line_break_params> <badness> <penalty> <hyphen-demerits> <cur-hyphen> <prev-hyphen> <cur-fit> <prev-fit>|
  calculates the demerits of the line from its <badness>, the <penalty> of the break-point, the penalty
  <hyphen-demerits> for two consecutive hyphenations, two flags <cur-hyphen> and <prev-hyphen> indicating
  whether the current and the previous break-point is due to a hyphenation, and the fitness of the current
  and the previous line.
*)
let calc_demerits line_break_params badness penalty hyphen_demerits cur_hyphen prev_hyphen cur_fit prev_fit =
  let alpha =
    if cur_hyphen && prev_hyphen then hyphen_demerits else num_zero in
  let beta = add_num line_break_params.line_penalty badness in
  let gamma =
    if (abs (cur_fit - prev_fit)) > 1
    then line_break_params.adj_demerits
    else num_zero
  in
    if ge_num penalty num_zero
    then
      add_num
        (add_num (add_num (mult_num beta beta) (mult_num penalty penalty))
           alpha)
        gamma
    else
      if gt_num penalty minus_infinite
      then
        add_num
          (add_num (sub_num (mult_num beta beta) (mult_num penalty penalty))
             alpha)
          gamma
      else add_num (add_num (mult_num beta beta) alpha) gamma
  
let very_loose_fit = 0
  
(* lines wider than their stretchability *)
let loose_fit = 1
  
(* lines stretched by 1/2 to 1 times their stretchability *)
let decent_fit = 2
  
(* lines stretched or shrunk at most 1/2 of their stretch-/shrinkability *)
let tight_fit = 3
  
(* lines shrinked by 1/2 to 1 times their shrinkability *)
(*
  |calc_fitness <badness>| calculates the fitness of the line. <badness> is negative if the line has
  to be shrunk.
*)
let calc_fitness badness =
  if ge_num badness num_100 then
    very_loose_fit
  else if ge_num badness num_13 then
    loose_fit
  else if le_num badness num_m13 then
    tight_fit
  else
    decent_fit

(*-----------------------------------------------------------------------*)
  
module Fast =
struct

  (* list of break_points *)
  type break_point = {
    bp_pos : int;           (* index into the list of boxes *)
    bp_prev : int;          (* number of the previous break point *)
    bp_line : int; (* the number of the line before the break point *)
    bp_fit : int;  (* fitness of this break *)
    bp_hyph : bool;    (* is this break point due to hyphenation? *)
    bp_forced : bool;  (* is this break forced? *)
    bp_demerits : num
  } (* with sexp_of *)
      
  (* demerits of the break *)
  type break_delta =
    | Break of break_point
    | Delta of xdim     (* with sexp_of *)
          
  (* |log_break_point <break_point> <number>| prints a description of <break_point>. *)
  let log_break_point bp n =
    (log_string "@@";
     log_int n;
     log_string ": line ";
     log_int bp.bp_line;
     log_string ".";
     log_int bp.bp_fit;
     if bp.bp_hyph then log_string "-" else ();
     log_string " t=";
     log_num bp.bp_demerits;
     log_string " -> @@";
     log_int bp.bp_prev;
     log_string "\n")
      
  (*
    |update_breaks <pos> <prev> <line> <fit> <hyph> <demerits> <new_breaks>| inserts a new break-point into
    the list <new_breaks> if there isn't already a better break-point present.
  *)
  let update_breaks pos prev line fit hyph forced demerits new_breaks line_break_params =
    let rec iter breaks =
      match breaks with
        | [] ->
            [ Break
                { bp_pos = pos;
                  bp_prev = prev;
                  bp_line = line;
                  bp_fit = fit;
                  bp_hyph = hyph;
                  bp_forced = forced;
                  bp_demerits = demerits } ]
        | b :: bs ->
            match b with
              | Delta _ -> assert false (* <new_breaks> contains only break points *) 
              | Break bp ->
                  if bp.bp_line = line then
                    if bp.bp_fit = fit then
                      if gt_num bp.bp_demerits demerits then
                        (Break
                           { bp_pos = pos;
                             bp_prev = prev;
                             bp_line = line;
                             bp_fit = fit;
                             bp_hyph = hyph;
                             bp_forced = forced;
                             bp_demerits = demerits }) :: bs
                      else
                        breaks
                    else if gt_num demerits (add_num bp.bp_demerits line_break_params.adj_demerits) then
                      breaks
                    else if lt_num (add_num demerits line_break_params.adj_demerits) bp.bp_demerits then
                      iter bs
                    else
                      b :: (iter bs)
                  else
                    b :: (iter bs)
    in
      iter new_breaks
        
  type break_state = {
    bs_number : int;
    bs_position : int;
    bs_dist : xdim;
    bs_discarding : xdim option;
    bs_active : break_delta list;
    bs_passive : break_delta list;
  } (* with sexp_of *)
      
  let break_lines ~par_params ~line_break_params loc boxes =
    (* FIX: check that left- and right-skip don't contain infinite
       shrinkability *)
    let left_right_skip = xdim_add_dim (dim_to_xdim par_params.left_skip) par_params.right_skip in
      (* |insert_delta <dist> <active>| inserts a delta node into the active list. *)
    let insert_delta dist active =
      match active with
        | [] -> [ Delta dist ]
        | Delta d :: ds -> (Delta (xdim_add d dist)) :: ds
        | Break b :: _ ->
            let rec iter pos active =
              match active with
                | [] -> [ Delta dist ]
                | Delta d :: ds -> (Delta (xdim_add d dist)) :: ds
                | Break b :: bs ->
                    if pos = b.bp_pos then
                      (Break b) :: (iter pos bs)
                    else
                      (Delta dist) :: active
            in
              iter b.bp_pos active
    in
      (* |inc_pos <box> <state>| moves on to the next box. *)
    let inc_pos box state =
      { bs_number = state.bs_number;
        bs_position = state.bs_position + 1;
        bs_dist = xdim_add_dim state.bs_dist box.b_width;
        bs_discarding = None;
        bs_active =
          (match state.bs_discarding with
             | Some dist -> insert_delta dist state.bs_active
             | None -> state.bs_active);
        bs_passive = state.bs_passive }
    in
      (* |skip_glue <box> <state>| moves on to the next box where the current box is a glue-box. *)
    let skip_glue box state =
      match state.bs_discarding with
        | Some dist ->
            if is_discardable_glue box then
              { bs_number = state.bs_number;
                bs_position = state.bs_position + 1;
                bs_dist = state.bs_dist;
                bs_discarding = Some (xdim_add_dim dist box.b_width);
                bs_active = state.bs_active;
                bs_passive = state.bs_passive }
            else
              { bs_number = state.bs_number;
                bs_position = state.bs_position + 1;
                bs_dist = xdim_add_dim state.bs_dist box.b_width;
                bs_discarding = None;
                bs_active = insert_delta dist state.bs_active;
                bs_passive = state.bs_passive }
        | None ->
            { bs_number = state.bs_number;
              bs_position = state.bs_position + 1;
              bs_dist = xdim_add_dim state.bs_dist box.b_width;
              bs_discarding = None;
              bs_active = state.bs_active;
              bs_passive = state.bs_passive }
    in
      (*
        |try_break <threshold> <hyphen-demerits> <force-active> <background-width> <break-box> <state>|
        decides whether the break-node <break-box> at position <pos> is feasible and updates the lists of
        active and passive break-points accordingly. <threshold> contains the amount of badness which is
        allowed, <hyphen-demerits> is the penalty for two consecutive hyphenations, <background-width>
        contains the width of an empty line, and if <force-active> is |True| the functions ensures that the
        list of active nodes never becomes empty.
      *)
    let try_break threshold hyphen_demerits background_width force_active break_box state =
      let (penalty, hyph, pre_break, post_break) =
        match break_box.b_contents with
          | BreakBox (p, h, pre, post, _) -> (p, h, pre, post)
          | _ -> assert false
      in
      let no_break_width = break_box.b_width in
      let pre_break_width = HBox.calc_width pre_break in
      let post_break_width = HBox.calc_width post_break in
      let forced_break = le_num penalty minus_infinite in
      let iter_breaks cur_dist n act new_breaks =
        let new_act = ListBuilder.make () in
        let rec iter cur_dist n act new_breaks =
          match act with
            | [] ->
                (new_breaks, ListBuilder.get new_act, state.bs_passive)
            | cur_act :: acts ->
                begin
                  match cur_act with
                    | Delta dist ->
                        ListBuilder.add new_act cur_act;
                        iter (xdim_add cur_dist dist) n acts new_breaks
                    | Break bp ->
                        let (left_indent, right_indent) = par_params.par_shape bp.bp_line in
                        let width = sub_num (sub_num par_params.measure left_indent) right_indent in
                        let adjustment_ratio = calc_adjust_ratio cur_dist width background_width in
                        let badness = badness adjustment_ratio in
                          if lt_num adjustment_ratio num_m1 then (* stop scanning for break-points *)
                            if force_active && ListBuilder.is_empty new_act && new_breaks = [] then
                              begin (* prevent active list from becoming empty *)
                                if !tracing_line_breaks then
                                  begin
                                    if new_breaks = [] then
                                      log_string "\n";
                                    log_string "@emergency break via @@";
                                    log_int n;
                                    log_string "\n"
                                  end;
                                (update_breaks state.bs_position n (bp.bp_line + 1) tight_fit
                                   false forced_break bp.bp_demerits [] line_break_params,
                                 [],
                                 act @ state.bs_passive)
                              end
                            else
                              (new_breaks, ListBuilder.get new_act, act @ state.bs_passive)
                          else
                            if gt_num badness threshold then (* no break possible *)
                              if not bp.bp_forced then
                                begin
                                  ListBuilder.add new_act cur_act;
                                  iter cur_dist (n - 1) acts new_breaks
                                end
                              else
                                begin (* don't scan past a forced break *)
                                  ListBuilder.add new_act cur_act;
                                  (new_breaks, ListBuilder.get new_act, acts @ state.bs_passive)
                                end
                            else (* break possible *)
                              begin
                                let fit = calc_fitness (if lt_num adjustment_ratio num_zero then minus_num badness else badness) in
                                let demerits =
                                  (*if forced_break then
                                    num_zero
                                    else *)
                                  calc_demerits line_break_params badness penalty hyphen_demerits hyph bp.bp_hyph fit bp.bp_fit in
                                let total_demerits =
                                  add_num bp.bp_demerits demerits
                                in
                                  if !tracing_line_breaks
                                  then
                                    begin
                                      if new_breaks = [] then
                                        log_string "\n";
                                      log_string "@break via @@";
                                      log_int n;
                                      log_string " b=";
                                      log_num badness;
                                      log_string " p=";
                                      log_num penalty;
                                      log_string " d=";
                                      log_num demerits;
                                      log_string "\n"
                                    end;
                                  ListBuilder.add new_act cur_act;
                                  iter cur_dist (n - 1) acts
                                    (update_breaks state.bs_position n
                                       (bp.bp_line + 1) fit hyph forced_break
                                       total_demerits new_breaks
                                       line_break_params)
                              end
                end
        in
          iter cur_dist n act new_breaks
      in
      let (new_act, act, pas) = iter_breaks (xdim_add_dim state.bs_dist pre_break_width) state.bs_number state.bs_active [] in
        if !tracing_line_breaks then
          ignore
            (List.fold_right
               (fun bp n ->
                  ((match bp with
                      | Break b -> log_break_point b n
                      | _ -> ());
                   n + 1))
               new_act (state.bs_number + 1));
        if new_act = [] then
          { bs_number = state.bs_number;
            bs_position = state.bs_position + 1;
            bs_dist = xdim_add_dim state.bs_dist no_break_width;
            bs_discarding = state.bs_discarding;
            bs_active = act;
            bs_passive = pas }
        else
          let inter_dist = xdim_sub_dim (xdim_add_dim state.bs_dist no_break_width) post_break_width in
            if post_break = [] then
              { bs_number = state.bs_number + (List.length new_act);
                bs_position = state.bs_position + 1;
                bs_dist = xdim_zero;
                bs_discarding = Some xdim_zero;
                bs_active =
                  new_act @
                    ((match state.bs_discarding with
                        | Some dist -> [ Delta (xdim_add inter_dist dist) ]
                        | None -> [ Delta inter_dist ]) @ act);
                bs_passive = pas }
            else
              { bs_number = state.bs_number + (List.length new_act);
                bs_position = state.bs_position + 1;
                bs_dist = dim_to_xdim post_break_width;
                bs_discarding = None;
                bs_active =
                  new_act @
                    ((match state.bs_discarding with
                        | Some dist -> [ Delta (xdim_add inter_dist dist) ]
                        | None -> [ Delta inter_dist ]) @ act);
                bs_passive = pas }
    in
      (* |split_lines <cur-break> <breaks> <boxes>| splits the list of boxes into the individual lines. *)
    let split_lines cur_break breaks boxes =

      let get_subrange arr from_pos to_pos =
        let rec iter result i =
          if i < from_pos then
            result
          else
            iter (arr.(i) :: result) (i - 1)
        in
          iter [] to_pos
      in

      let boxes = Array.of_list boxes in

      let rec iter cur_break lines =
        if cur_break.bp_pos = 0 then
          lines
        else
          let prev = breaks.(cur_break.bp_prev) in
          let (post_break, first_pos) =
            match boxes.(prev.bp_pos).b_contents with
              | BreakBox (_, _, _, p, _) -> (p, prev.bp_pos + 1)
              | _ -> ([], prev.bp_pos)
          in
          let pre_break =
            match boxes.(cur_break.bp_pos).b_contents with
              | BreakBox (_, _, p, _, _) -> p
              | _ -> []
          in
          let line = get_subrange boxes first_pos (cur_break.bp_pos - 1) in
          let (cmds, new_line) = discard_glue (post_break @ remove_breaks line @ pre_break)
          in
            iter prev ((cmds @ new_line) :: lines)
      in
        iter cur_break []
    in
      (*
        |check_result <boxes> <state>| tests whether there is a feasible break-point at the end of the
        paragraph.
      *)
    let check_result boxes state =

      let end_pos = (List.length boxes) - 1 in

      let rec find_best break_points =
        let rec iter i best =
          if i < 0 then
            break_points.(best)
          else if break_points.(i).bp_pos < end_pos then
            break_points.(best)
          else if lt_num break_points.(i).bp_demerits break_points.(best).bp_demerits then
            iter (i - 1) i
          else
            iter (i - 1) best
        in
          iter ((Array.length break_points) - 2) ((Array.length break_points) - 1)
      in

      let rec find_line best looseness break_points =
        let rec iter i best =
          if i < 0 then
            best
          else
            let delta = break_points.(i).bp_line - best.bp_line in
              if break_points.(i).bp_pos < end_pos
              then
                best
              else if looseness = 0 then
                best
              else if looseness > 0 then
                if delta > 0 && delta <= looseness then
                  iter (looseness - delta) break_points.(i)
                else
                  iter looseness best
              else if delta < 0 && delta >= looseness then
                iter (looseness - delta) break_points.(i)
              else
                iter looseness best
        in
          iter ((Array.length break_points) - 1) best
      in
      let breaks =
        Array.of_list
          (List.fold_left
             (fun l bp -> match bp with | Break b -> b :: l | _ -> l) []
             (state.bs_active @ state.bs_passive))
      in
      let num_breaks = Array.length breaks in
        if num_breaks = 0 then
          None
        else
          let best_break =
            if line_break_params.looseness = 0 then
              find_best breaks
            else
              find_line (find_best breaks) line_break_params.looseness breaks
          in
            if breaks.(num_breaks - 1).bp_pos <> end_pos then
              None
            else
              Some (split_lines best_break breaks boxes)
    in
      (*
        |pass <tolerance> <left-right-skip> <allow-hyphen> <force-active> <state> <boxes>|
        is the main loop of the algorithm. It scans the paragraph and checks every possible
        break-point.
      *)
    let pass tolerance left_right_skip allow_hyphen force_active state
        par_boxes =
      let rec iter boxes state =
        match boxes with
          | [] -> check_result par_boxes state
          | b :: bs ->
              if (state.bs_active = []) && (not force_active) then
                None
              else
                begin
                  if !tracing_line_breaks then
                    log_box b;

                  match b.b_contents with

                    | BreakBox (_, h, _, _, _) ->
                        if (not h) || allow_hyphen then
                          iter bs
                            (try_break tolerance
                               (if bs = [] then
                                  line_break_params.final_hyphen_demerits
                                else
                                  line_break_params.double_hyphen_demerits)
                               left_right_skip force_active b state)
                        else if is_real_box b then
                          iter bs (inc_pos b state)
                        else
                          iter bs { state with bs_position = state.bs_position + 1 }

                    | GlueBox (_, _) -> iter bs (skip_glue b state)

                    | _ ->
                        if is_real_box b then
                          iter bs (inc_pos b state)
                        else
                          iter bs { state with bs_position = state.bs_position + 1 }
                end
      in
        iter par_boxes state
    in
    let initial_state =
      {
        bs_number = 0;
        bs_position = 0;
        bs_dist = xdim_zero;
        bs_discarding = None;
        bs_active =
          [ Break
              {
                bp_pos = 0;
                bp_prev = 0;
                bp_line = 0;
                bp_fit = decent_fit;
                bp_hyph = false;
                bp_forced = true;
                bp_demerits = num_zero;
              } ];
        bs_passive = [];
      }
    in
      if !tracing_line_breaks then
        log_info loc "@firstpass\n";
      match pass line_break_params.pre_tolerance left_right_skip false
        false initial_state boxes
      with
        | Some x -> x
        | None ->
            if !tracing_line_breaks then
              log_info loc "@secondpass\n";
            match pass line_break_params.tolerance left_right_skip true false initial_state boxes with
              | Some x -> x
              | None ->
                  if !tracing_line_breaks then
                    log_info loc "@emergencypass\n";
                  match pass line_break_params.tolerance
                    (xdim_add_dim left_right_skip
                       { d_base = num_zero;
                         d_stretch_factor = line_break_params.emergency_stretch;
                         d_stretch_order = 1;
                         d_shrink_factor = num_zero;
                         d_shrink_order = 0 })
                    true true initial_state boxes
                  with
                    | Some x -> x
                    | None -> assert false
end

(*-----------------------------------------------------------------------*)
  
module Good =
struct

    type break_graph = {
      bg_items : extended_glyph_item array;
      bg_breaks : int array;
      bg_left_right_skip : xdim;
      bg_threshold : num;
      bg_par_params : par_params;
      bg_line_break_params : line_break_params;
    } (* with sexp_of *)
    
    type break_point = {
      bp_previous : break_point;      (* the previous break point *)
      bp_line_no : int;               (* the number of the line before the break point *)
      bp_line : box list;             (* the line before the break point *)
      bp_fit : int;                   (* fitness of this break *)
      bp_rivers : (num * num * num) list; (* <from-x> <to-x> <demerits> *)
      bp_hyph : bool;                 (* is this break point due to hyphenation? *)
      bp_forced : bool;               (* is this break forced? *)
      bp_demerits : num;              (* demerits of the break *)
    } (* with sexp_of *)

    type partial_line = {
      (* The prefix of the line, which is known not to change anymore. (In
         reversed order.) *)
      pl_prefix : box list;

      (* The rivers found in the prefix. *)
      pl_rivers : xdim list;

      (* The position in |graph.bg_items| where the prefix ends. *)
      pl_position : int;

      (* The width of the prefix. *)
      pl_width : xdim;
    } (* with sexp_of *)

    let make_break_graph ~is_breakable_item ~threshold ~left_right_skip ~par_params ~line_break_params items =

      let breaks = ref [] in
        for k = Array.length items - 1 downto 0 do
          if is_breakable_item items.(k) then
            breaks := k :: !breaks
        done;

        (* FIX: check that left-skip and right-skip don't contain
           infinite shrinkability. *)
        { bg_items = items;
          bg_breaks = Array.of_list !breaks;
          bg_left_right_skip = left_right_skip;
          bg_threshold = threshold;
          bg_par_params = par_params;
          bg_line_break_params = line_break_params }

    let is_forced_break_point graph bp =
      le_num (Substitute.get_break_penalty graph.bg_items.(graph.bg_breaks.(bp))) minus_infinite
        
    let insert_break_point graph break_points new_bp =
      let rec iter break_points =
        match break_points with
          | [] -> [ new_bp ]
          | b :: bs ->
              (* We keep <break_points> sorted (lexicographically w.r.t. |bp_line_no| and |bp_fit|). *)
              if b.bp_line_no < new_bp.bp_line_no then
                b :: (iter bs)
              else if new_bp.bp_line_no < b.bp_line_no then
                new_bp :: break_points
              else if b.bp_fit = new_bp.bp_fit then (* Take the better one. *)
                if le_num b.bp_demerits new_bp.bp_demerits then
                  break_points
                else
                  new_bp :: bs
                    (* Optimisation: Taking a predecessor with a
                       different fit value increases the demerits at
                       most by |adj_demerits|. If the difference is
                       greater than this value then we can discard one
                       of the break points.  FIX: The next two tests
                       need to be adapted if we add river
                       detection. *)
              else if gt_num new_bp.bp_demerits (add_num b.bp_demerits graph.bg_line_break_params.adj_demerits) then
                break_points
              else if lt_num (add_num new_bp.bp_demerits graph.bg_line_break_params.adj_demerits) b.bp_demerits then
                iter bs
              else if b.bp_fit < new_bp.bp_fit then
                b :: (iter bs)
              else (* b.bp_fit > new_bp.bp_fit *)
                new_bp :: break_points
      in
        iter break_points
      
    let calc_rivers params adj_ratio width last_rivers current_rivers =
      if le_num params.river_demerits num_zero then
        (num_zero, [])                  (* Abort early. *)
      else
        let scale d = (dim_scale (xdim_select_order d width.d_stretch_order width.d_shrink_order) adj_ratio).d_base in
        let rec scale_rivers x rivers =
          match rivers with
            | [] -> assert false       (* <rivers> is of odd length. *)
            | [ _ ] -> []
            | a :: b :: rs ->
                let delta = scale a in (* distance to start of white space *)
                let width = scale b in (* width of white space *)
                let right = add_num delta width in (* position of right border *)
                  (* Ignore tiny white space. *)
                  if gt_num width params.river_threshold then
                    (add_num x delta, right) :: (scale_rivers right rs)
                  else
                    scale_rivers right rs
        in                    (* FIX: add left-skip and left-indent *)
        let scaled_rivers = scale_rivers num_zero current_rivers in
        let result = ListBuilder.make () in
        let rec merge_rivers demerits last current =
          match current with
            | [] -> (demerits, (ListBuilder.get result))
            | (a, b) :: cs ->
                let rec iter last =
                  match last with
                    | [] ->
                        List.iter
                          (fun (a, b) ->
                             ListBuilder.add result (a, b, num_zero))
                          current;
                        (demerits, (ListBuilder.get result))
                    | (x, y, d) :: zs ->
                        if le_num y a then
                          iter zs
                        else
                          if ge_num x b then
                            begin
                              ListBuilder.add result (a, b, num_zero);
                              merge_rivers demerits last cs
                            end
                          else
                            let u = max_num a x in
                            let v = min_num b y in
                            let new_dem = add_num d (mult_num (sub_num v u) params.river_demerits) in
                              ListBuilder.add result (a, b, new_dem);
                              merge_rivers (add_num demerits new_dem) last cs
                in iter last
        in
          merge_rivers num_zero last_rivers scaled_rivers
      
    let calc_line_demerits graph prev_bp is_final hyph fit badness penalty =
      let hyphen_demerits =
        if is_final then
          graph.bg_line_break_params.final_hyphen_demerits
        else
          graph.bg_line_break_params.double_hyphen_demerits in
      let demerits =
        calc_demerits graph.bg_line_break_params badness penalty
          hyphen_demerits hyph prev_bp.bp_hyph fit prev_bp.bp_fit
      in
        add_num prev_bp.bp_demerits demerits
      
    let make_break_point graph prev_bp line rivers width is_final forced_break hyph adj_ratio badness penalty =
      let fit = calc_fitness (if lt_num (fst adj_ratio) num_zero then minus_num badness else badness) in
      let (river_demerits, new_rivers) = calc_rivers graph.bg_line_break_params adj_ratio width prev_bp.bp_rivers rivers in
      let demerits = add_num river_demerits (calc_line_demerits graph prev_bp is_final hyph fit badness penalty) in
        if !tracing_line_breaks then
          begin
            List.iter log_box line;
            (* List.iter long_dump_box line;*)
            log_string "\n@break";
            (* log_int n;*)
            log_string ": line ";
            log_int (prev_bp.bp_line_no + 1);
            log_string ".";
            log_int fit;
            if hyph then log_string "-";
            log_string " b=";
            log_num badness;
            log_string " p=";
            log_num penalty;
            log_string " t=";
            log_num demerits;
            log_string "\n"
          end;
        { bp_previous = prev_bp;
          bp_line_no = prev_bp.bp_line_no + 1;
          bp_line = line;
          bp_fit = fit;
          bp_rivers = new_rivers;
          bp_hyph = hyph;
          bp_forced = forced_break;
          bp_demerits = demerits }
      
    let rec rev_append_rivers r1 r2 =
      match r1 with
        | [] -> assert false            (* Rivers have odd length. *)
        | x :: xs ->
            match r2 with
              | [] -> assert false
              | y :: ys -> List.rev_append xs ((xdim_add x y) :: ys)

    let compute_line graph partial_line previous current =

      let detecting_rivers = lt_num num_zero graph.bg_line_break_params.river_demerits in

      let revapp_rivers =
        if detecting_rivers then
          rev_append_rivers
        else
          (fun _r1 _r2 -> [])
      in

      let calculate_width =
        if detecting_rivers then
          HBox.calc_width_and_glue
        else
          (fun boxes -> (HBox.calc_xwidth boxes, []))
      in

      let return_result partial_line new_pos boxes1 boxes2 =
        let (width1, rivers1) = calculate_width boxes1 in
        let (width2, rivers2) = calculate_width boxes2 in
        let rivers = (revapp_rivers partial_line.pl_rivers (revapp_rivers rivers1 rivers2)) in
        let new_partial_line =
          { pl_prefix = boxes1 @ partial_line.pl_prefix;
            pl_rivers = revapp_rivers rivers1 partial_line.pl_rivers;
            pl_position = new_pos;
            pl_width = xdim_add partial_line.pl_width width1 }
        in
          (List.rev_append new_partial_line.pl_prefix boxes2,
           rivers,
           xdim_add new_partial_line.pl_width width2,
           new_partial_line)
      in

        if partial_line.pl_position < 0 then

          (* no precomputed information available *)

          (* FIX: pre_break and post_break should depend on the line number *)
          let post_break =
            Array.append
              (Array.of_list graph.bg_par_params.post_break)
              (Substitute.get_post_break graph.bg_items.(previous))
          in
          let pre_break =
            Array.append
              (Substitute.get_pre_break graph.bg_items.(current))
              (Array.of_list graph.bg_par_params.pre_break)
          in

          let (cmds1, pos1) = Compose.discard_glue_array (previous + 1) (current - 1) graph.bg_items in

            if current <= pos1 then

              (* All of the regular items were discarded. To keep
                 things simple we do not precompute a partial line in
                 this case. *)

              let (cmds2, pos2) = Compose.discard_glue_array 0 (Array.length pre_break - 1) pre_break in
              let boxes = XList.append_sub_array pre_break pos2 (Array.length pre_break - 1) [] in
              let line = XList.append_sub_array post_break 0 (Array.length post_break - 1) (cmds1 @ cmds2 @ boxes) in
              let boxes = List.map extended_item_to_box line in
              let (width, rivers) = calculate_width boxes in
                (boxes, rivers, width, partial_line)

            else

              let items1 = XList.from_sub_array graph.bg_items pos1 (current - 1) in
              let line_prefix = XList.append_sub_array post_break 0 (Array.length post_break - 1) (cmds1 @ items1) in
              let (prefix, len, rest) = JustHyph.add_lig_kern_iterative_list ~keep_breaks:false [] line_prefix in
              let prefix_pos = pos1 + len - Array.length post_break - List.length cmds1 in
              let suffix =
                JustHyph.add_lig_kern
                  ~keep_breaks:false
                  (rest @ (XList.append_sub_array pre_break 0 (Array.length pre_break - 1) []))
              in
              let boxes1 = List.map simple_item_to_box prefix in
              let boxes2 = List.map simple_item_to_box suffix in
                return_result partial_line prefix_pos boxes1 boxes2

        else (* we have already precomputed a prefix of the line *)

          (* FIX: pre_break should depend on the line number *)
          let pre_break = Array.append
            (Substitute.get_pre_break graph.bg_items.(current))
            (Array.of_list graph.bg_par_params.pre_break)
          in

          let (new_prefix, prefix_pos) =
            JustHyph.add_lig_kern_iterative_array
              ~keep_breaks:false
              []
              partial_line.pl_position
              (current - 1)
              graph.bg_items
          in
          let line_suffix =
            JustHyph.add_lig_kern
              ~keep_breaks:false
              (XList.append_sub_array graph.bg_items prefix_pos (current - 1)
                 (XList.append_sub_array pre_break 0 (Array.length pre_break - 1) []))
          in
          let boxes1 = List.map simple_item_to_box new_prefix in
          let boxes2 = List.map simple_item_to_box line_suffix in
            return_result partial_line prefix_pos boxes1 boxes2
      
    let update_breaks graph previous_breaks partial_line previous current breaks =
      let new_line = ref None in
      let rec iter last_line_no new_breaks breaks =
        match breaks with
          | [] ->
              begin
                match !new_line with
                  | None -> (new_breaks, Some partial_line)
                  | Some (_, _, _, pl) -> (new_breaks, Some pl)
              end
          | b :: bs ->
              if b.bp_line_no = last_line_no then
                (* We have already considered this line. Since the result depends
                   only on the line number (via par-shape) we do not need to compute
                   the demerits again. *)
                iter last_line_no new_breaks bs
              else
                let (left_indent, right_indent) = graph.bg_par_params.par_shape b.bp_line_no in
                let goal_width = sub_num (sub_num graph.bg_par_params.measure right_indent) left_indent in
                  if (lt_num goal_width (xdim_min_value (xdim_add partial_line.pl_width graph.bg_left_right_skip)) &&
                        previous + 1 < current) then
                    (* Abort early since the line is too long. *)
                    iter b.bp_line_no new_breaks bs
                  else
                    let previous_pos = graph.bg_breaks.(previous) in
                    let current_pos = graph.bg_breaks.(current) in
                    let break = graph.bg_items.(current_pos) in
                    let penalty = Substitute.get_break_penalty break in
                    let hyph = Substitute.break_is_hyph break in
                    let forced_break = le_num penalty minus_infinite in
                    let (line, rivers, line_width, _) =
                      match !new_line with
                        | Some l -> l
                        | None ->
                            let l = compute_line graph partial_line previous_pos current_pos in
                              new_line := Some l;
                              l
                    in
                    let total_width = xdim_to_dim (xdim_add line_width graph.bg_left_right_skip) in
                    let adj_ratio = adjustment_ratio total_width goal_width in
                    let badness = dim_scale_badness adj_ratio in
                    let badness2 =
                      if (gt_num badness graph.bg_threshold &&
                            gt_num total_width.d_base goal_width &&
                            previous + 1 = current) then
                        (* If already the first break point is too far away,
                           there is no proper line-breaking solution. To get
                           some reasonable output we simply allow the break. *)
                        num_zero
                      else
                        badness
                    in
                      if gt_num badness2 graph.bg_threshold then (* break not possible *)
                        iter b.bp_line_no new_breaks bs
                      else
                        (* add a new break point to the list *)
                        let new_bp =
                          make_break_point graph b line rivers total_width
                            (current = Array.length graph.bg_breaks - 1)
                            forced_break hyph adj_ratio badness2 penalty
                        in
                          iter b.bp_line_no (insert_break_point graph new_breaks new_bp) bs
      in
        iter (-1) breaks previous_breaks
      
    let compute_best_break graph breaks =
      let num_breaks = Array.length breaks in
        match breaks.(num_breaks - 1) with
          | [] -> None
          | b :: bs ->
              let rec find_best best breaks =
                match breaks with
                  | [] -> best
                  | b :: bs ->
                      if lt_num b.bp_demerits best.bp_demerits then
                        find_best b bs
                      else
                        find_best best bs
              in
              let rec get_break best looseness breaks =
                match breaks with
                  | [] -> best
                  | b :: bs ->
                      let delta = b.bp_line_no - best.bp_line_no in
                        if delta = 0 then
                          if lt_num b.bp_demerits best.bp_demerits then
                            get_break b looseness bs
                          else
                            get_break best looseness bs
                        else if (0 < delta && delta <= looseness) || (delta < 0 && looseness <= delta) then
                          get_break b (looseness - delta) bs
                        else
                          get_break best looseness bs
              in
                Some (get_break (find_best b bs)
                        graph.bg_line_break_params.looseness
                        breaks.(num_breaks - 1))
      
    let get_lines bp =
      let rec iter bp lines =
        if bp.bp_line_no > 0 then
          iter bp.bp_previous (bp.bp_line :: lines)
        else
          lines
      in
        iter bp []

    let break_lines ~par_params ~line_break_params loc items =
      let rec initial_bp = {
        bp_previous = initial_bp;
        bp_line_no  = 0;
        bp_line     = [];
        bp_fit      = decent_fit;
        bp_rivers   = [];
        bp_hyph     = false;
        bp_forced   = true;
        bp_demerits = num_zero;
      }
      in
      let pass ~is_breakable_item ~tolerance ~left_right_skip =
        let first_break = `Break (num_zero, false, [| |], [| |], [| |]) in
        let item_array = (Array.of_list (first_break :: items)) in
        let graph =
          make_break_graph
            ~is_breakable_item
            ~threshold:tolerance
            ~left_right_skip
            ~par_params
            ~line_break_params
            item_array
        in
        let initial_data = {
          pl_prefix       = [];
          pl_rivers       = [xdim_zero];
          pl_position     = (-1);
          pl_width        = xdim_zero;
        }
        in
          ShortestPath.find_shortest_path
            update_breaks
            is_forced_break_point
            compute_best_break
            initial_bp
            initial_data
            graph
            (Array.length graph.bg_breaks)
      in

      let left_right_skip = xdim_add_dim (dim_to_xdim par_params.left_skip) par_params.right_skip in

      let log_pass message =
        if !tracing_line_breaks then
          log_string message
      in

      let first_pass () =
        (* A quick check for an acceptable paragraph that has no
           hyphenated breaks. *)
        log_pass "\n@firstpass\n";
        pass
          ~is_breakable_item:Substitute.is_nonhyph_break
          ~tolerance:line_break_params.pre_tolerance
          ~left_right_skip
      in

      let second_pass () =
        log_pass "\n\n@secondpass\n";
        pass
          ~is_breakable_item:Substitute.is_break
          ~tolerance:line_break_params.tolerance
          ~left_right_skip
      in

      let emergency_pass n emergency_stretch =
        log_pass ("\n\n@emergencypass " ^ string_of_int n ^ "\n");
        let emergency_slack =
          { d_base = num_zero;
            d_stretch_factor = emergency_stretch;
            d_stretch_order = 0;
            d_shrink_factor = num_zero;
            d_shrink_order = 0 }
        in
          pass
            ~is_breakable_item:Substitute.is_break
            ~tolerance:line_break_params.tolerance
            ~left_right_skip:(xdim_add_dim left_right_skip emergency_slack)
      in

      let final_emergency_pass () =
        log_pass "\n\n@final emergencypass\n";
        let overwhelming_emergency_slack =
          { d_base = left_right_skip.xd_base;
            d_stretch_factor = num_one;
            d_stretch_order = 1;
            d_shrink_factor = num_one;
            d_shrink_order = 1 }
        in
          pass
            ~is_breakable_item:Substitute.is_break
            ~tolerance:line_break_params.tolerance
            ~left_right_skip:(dim_to_xdim overwhelming_emergency_slack)
      in

        match first_pass () with
          | Some bp -> get_lines bp
          | None ->
              match second_pass () with
                | Some bp -> get_lines bp
                | None ->
                    log_warn loc "Inserting emergency stretch!";
                    let rec iter n emergency_stretch =
                      if 999 <= n then
                        match final_emergency_pass () with
                          | Some bp -> get_lines bp
                          | None -> assert false
                      else
                        match emergency_pass n emergency_stretch with
                          | Some bp -> get_lines bp
                          | None -> iter (n + 1) (mult_num num_two emergency_stretch)
                    in
                      iter 1 (max_num num_1_2 line_break_params.emergency_stretch)
  end
    
(* check that <items> don't contain infinitely shrinkable glue *)
let check_shrinkage loc items =
  let check_box box =
    let width = box.b_width in
      if width.d_shrink_factor = num_zero || width.d_shrink_order = 0 then
        box
      else
        begin
          log_warn loc "Paragraph contains infinitely shrinkable glue!\n";
          (* set minimal width of the box to 0 *)
          { box with b_width = { width with
                                   d_shrink_factor = width.d_base;
                                   d_shrink_order = 0 } }
        end
  in
  let check item =
    match item with
      | `Glyph _ -> item
      | `Kern  _ -> item
      | `Break _ -> item
      | `Command box -> `Command (check_box box)
      | `Box box -> `Box (check_box box)
  in
    List.map check items
  
(* add par-indent and par-fill-skip *)
let add_par_fill_skip ~par_params items =
  let (cmds, par) = Compose.discard_glue (List.rev items) in
    `Command (new_glue_box par_params.par_indent dim_zero true false) ::
      List.rev
      begin
        `Break (minus_infinite, false, [|  |], [|  |], [|  |]) ::
          `Command (new_glue_box par_params.par_fill_skip dim_zero true true) ::
          (cmds @ par)
      end

(*-----------------------------------------------------------------------*)
(* break a paragraph into lines *)

let break_paragraph ~par_params ~line_break_params loc items =
  let par = add_par_fill_skip ~par_params (check_shrinkage loc items) in
    if line_break_params.simple_breaking then
      Fast.break_lines
        ~par_params
        ~line_break_params
        loc
        (List.map simple_item_to_box (JustHyph.add_lig_kern ~keep_breaks:true par))
    else
      Good.break_lines ~par_params ~line_break_params loc par

(*-----------------------------------------------------------------------*)
(* layout-line *)

let layout_line ~par_params width line_no line =
  let rec process_commands boxes =
    match boxes with
      | [] -> []
      | b :: bs ->
          match b.b_contents with
            | CommandBox (`ParCmd (CallParFunction f)) ->
                f line_no;
                process_commands bs
            | _ ->
                b :: (process_commands bs)
  in
  let (left_indent, right_indent) = par_params.par_shape line_no in
  let boxes =
    process_commands
      begin
        par_params.post_process_line
          begin
            [ new_glue_box
                (dim_add par_params.left_skip (fixed_dim left_indent)) dim_zero
                true false ] @
              line @
              [ new_glue_box
                  (dim_add par_params.right_skip (fixed_dim right_indent))
                  dim_zero true false ]
          end
      end
  in
    HBox.make_to HBox.LR width boxes

(*-----------------------------------------------------------------------*)

let empty_line_break_params =
  { pre_tolerance = num_zero;
    tolerance = num_zero;
    looseness = 0;
    line_penalty = num_zero;
    adj_demerits = num_zero;
    double_hyphen_demerits = num_zero;
    final_hyphen_demerits = num_zero;
    emergency_stretch = num_zero;
    river_demerits = num_zero;
    river_threshold = num_zero;
    simple_breaking = false }

let empty_par_params =
  { measure = num_zero;
    par_indent = dim_zero;
    par_fill_skip = dim_zero;
    par_skip = dim_zero;
    left_skip = dim_zero;
    right_skip = dim_zero;
    par_shape = (fun _ -> (num_zero, num_zero));
    pre_break = [];
    post_break = [];
    post_process_line = (fun x -> x) }

(*-----------------------------------------------------------------------*)
